home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b2tcP.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  6.2 KB  |  316 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b2tcP.c,v 1.4 85/08/22 16:57:02 timo Exp $
  5. */
  6.  
  7. /* polytype representation */
  8.  
  9. #include "b.h"
  10. #include "b1obj.h"
  11. #include "b2tcP.h"
  12.  
  13. /* A polytype is a compound with two fields.
  14.  * The first field is a B text, and holds the typekind.
  15.  * If the typekind is 'Variable', the second field is 
  16.  *   a B text, holding the identifier of the variable;
  17.  * otherwise, the second field is a compound of sub(poly)types,
  18.  *   indexed from 0 to one less then the number of subtypes.
  19.  */
  20.  
  21. #define Kin    0
  22. #define Sub    1
  23. #define Id    Sub
  24. #define Asc    0
  25. #define Key    1
  26.  
  27. #define Kind(u)        ((typekind) *Field((value) (u), Kin))
  28. #define Psubtypes(u)    (Field((value) (u), Sub))
  29. #define Ident(u)    (*Field((value) (u), Id))
  30.  
  31. typekind var_kind;
  32. typekind num_kind;
  33. typekind tex_kind;
  34. typekind lis_kind;
  35. typekind tab_kind;
  36. typekind com_kind;
  37. typekind t_n_kind;
  38. typekind l_t_kind;
  39. typekind tlt_kind;
  40. typekind err_kind;
  41.  
  42. polytype num_type;
  43. polytype tex_type;
  44. polytype err_type;
  45. polytype t_n_type;
  46.  
  47. /* Making, setting and accessing (the fields of) polytypes */
  48.  
  49. Visible polytype mkt_polytype(k, nsub) typekind k; intlet nsub; {
  50.     value u;
  51.     
  52.     u = mk_compound(2);
  53.     *Field(u, Kin)= copy((value) k);
  54.     *Field(u, Sub)= mk_compound(nsub);
  55.     return ((polytype) u);
  56. }
  57.  
  58. Procedure putsubtype(sub, u, isub) polytype sub, u; intlet isub; {
  59.     *Field(*Psubtypes(u), isub)= (value) sub;
  60. }
  61.  
  62. typekind kind(u) polytype u; {
  63.     return (Kind(u));
  64. }
  65.  
  66. intlet nsubtypes(u) polytype u; {
  67.     return (Nfields(*Psubtypes(u)));
  68. }
  69.  
  70. polytype subtype(u, i) polytype u; intlet i; {
  71.     return ((polytype) *Field(*Psubtypes(u), i));
  72. }
  73.  
  74. polytype asctype(u) polytype u; {
  75.     return (subtype(u, Asc));
  76. }
  77.  
  78. polytype keytype(u) polytype u; {
  79.     return (subtype(u, Key));
  80. }
  81.  
  82. value ident(u) polytype u; {
  83.     return (Ident(u));
  84. }
  85.  
  86. /* making new polytypes */
  87.  
  88. polytype mkt_number() {
  89.     return(p_copy(num_type));
  90. }
  91.  
  92. polytype mkt_text() {
  93.     return(p_copy(tex_type));
  94. }
  95.  
  96. polytype mkt_tn() {
  97.     return(p_copy(t_n_type));
  98. }
  99.  
  100. polytype mkt_error() {
  101.     return(p_copy(err_type));
  102. }
  103.  
  104. polytype mkt_list(s) polytype s; {
  105.     polytype u;
  106.     
  107.     u = mkt_polytype(lis_kind, 1);
  108.     putsubtype(s, u, Asc);
  109.     return (u);
  110. }
  111.  
  112. polytype mkt_table(k, a) polytype k, a; {
  113.     polytype u;
  114.     
  115.     u = mkt_polytype(tab_kind, 2);
  116.     putsubtype(a, u, Asc);
  117.     putsubtype(k, u, Key);
  118.     return (u);
  119. }
  120.  
  121. polytype mkt_lt(s) polytype s; {
  122.     polytype u;
  123.     
  124.     u = mkt_polytype(l_t_kind, 1);
  125.     putsubtype(s, u, Asc);
  126.     return (u);
  127. }
  128.  
  129. polytype mkt_tlt(s) polytype s; {
  130.     polytype u;
  131.     
  132.     u = mkt_polytype(tlt_kind, 1);
  133.     putsubtype(s, u, Asc);
  134.     return (u);
  135. }
  136.  
  137. polytype mkt_compound(nsub) intlet nsub; {
  138.     return mkt_polytype(com_kind, nsub);
  139. }
  140.  
  141. polytype mkt_var(id) value id; {
  142.     polytype u;
  143.     
  144.     u = mk_compound(2);
  145.     *Field(u, Kin)= copy((value) var_kind);
  146.     *Field(u, Id)= id;
  147.     return (u);
  148. }
  149.  
  150. Hidden value nnewvar;
  151.  
  152. polytype mkt_newvar() {
  153.     value v;
  154.     v = sum(nnewvar, one);
  155.     release(nnewvar);
  156.     nnewvar = v;
  157.     return mkt_var(convert(nnewvar, No, No));
  158. }
  159.  
  160. polytype p_copy(u) polytype u; {
  161.     return((polytype) copy((polytype) u));
  162. }
  163.  
  164. Procedure p_release(u) polytype u; {
  165.     release((polytype) u);
  166. }
  167.  
  168. /* predicates */
  169.  
  170. bool are_same_types(u, v) polytype u, v; {
  171.     if (compare((value) Kind(u), (value) Kind(v)) NE 0)
  172.         return (No);
  173.     else if (t_is_var(Kind(u)))
  174.         return (compare(Ident(u), Ident(v)) EQ 0);
  175.     else
  176.         return (
  177.             (nsubtypes(u) EQ nsubtypes(v))
  178.             &&
  179.             (compare(*Psubtypes(u), *Psubtypes(v)) EQ 0)
  180.         );
  181. }
  182.  
  183. bool have_same_structure(u, v) polytype u, v; {
  184.     return(
  185.         (compare((value) Kind(u), (value) Kind(v)) EQ 0)
  186.         &&
  187.         nsubtypes(u) EQ nsubtypes(v)
  188.     );
  189. }
  190.  
  191. bool t_is_number(kind) typekind kind; {
  192.     return (compare((value) kind, (value) num_kind) EQ 0 ? Yes : No);
  193. }
  194.  
  195. bool t_is_text(kind) typekind kind; {
  196.     return (compare((value) kind, (value) tex_kind) EQ 0 ? Yes : No);
  197. }
  198.  
  199. bool t_is_tn(kind) typekind kind; {
  200.     return (compare((value) kind, (value) t_n_kind) EQ 0 ? Yes : No);
  201. }
  202.  
  203. bool t_is_error(kind) typekind kind; {
  204.     return (compare((value) kind, (value) err_kind) EQ 0 ? Yes : No);
  205. }
  206.  
  207. bool t_is_list(kind) typekind kind; {
  208.     return (compare((value) kind, (value) lis_kind) EQ 0 ? Yes : No);
  209. }
  210.  
  211. bool t_is_table(kind) typekind kind; {
  212.     return (compare((value) kind, (value) tab_kind) EQ 0 ? Yes : No);
  213. }
  214.  
  215. bool t_is_lt(kind) typekind kind; {
  216.     return (compare((value) kind, (value) l_t_kind) EQ 0 ? Yes : No);
  217. }
  218.  
  219. bool t_is_tlt(kind) typekind kind; {
  220.     return (compare((value) kind, (value) tlt_kind) EQ 0 ? Yes : No);
  221. }
  222.  
  223. bool t_is_compound(kind) typekind kind; {
  224.     return (compare((value) kind, (value) com_kind) EQ 0 ? Yes : No);
  225. }
  226.  
  227. bool t_is_var(kind) typekind kind; {
  228.     return (compare((value) kind, (value) var_kind) EQ 0 ? Yes : No);
  229. }
  230.  
  231. bool has_number(kind) typekind kind; {
  232.     if (compare(kind, num_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
  233.         return (Yes);
  234.     else
  235.         return (No);
  236. }
  237.  
  238. bool has_text(kind) typekind kind; {
  239.     if (compare(kind, tex_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
  240.         return (Yes);
  241.     else
  242.         return (No);
  243. }
  244.  
  245. bool has_lt(kind) typekind kind; {
  246.     if (compare(kind, l_t_kind) EQ 0 || compare(kind, tlt_kind) EQ 0)
  247.         return (Yes);
  248.     else
  249.         return (No);
  250. }
  251.  
  252. /* The table "typeof" maps the identifiers of the variables (B texts)
  253.  * to polytypes.
  254.  */
  255.  
  256. value typeof;
  257.  
  258. Procedure repl_type_of(u, p) polytype u, p; {
  259.     replace((value) p, &typeof, Ident(u));
  260. }
  261.  
  262. bool table_has_type_of(u) polytype u; {
  263.     return(in_keys(Ident(u), typeof));
  264. }
  265.  
  266. polytype type_of(u) polytype u; {
  267.     return((polytype) *adrassoc(typeof, Ident(u)));
  268. }
  269.  
  270. polytype bottom_var(u) polytype u; {
  271.     polytype b;
  272.  
  273.     if (!t_is_var(Kind(u)))
  274.         return (u);
  275.     /* Kind(u) == Variable */
  276.     while (table_has_type_of(u)) {
  277.         b = type_of(u);
  278.         if (t_is_var(Kind(b)))
  279.             u = b;
  280.         else
  281.             break;
  282.     }
  283.     /* Kind(u) == Variable && !table_has_type_of(u)*/
  284.     return (u);
  285. }
  286.  
  287. Visible Procedure usetypetable(t) value t; {
  288.     typeof = t;
  289. }
  290.  
  291. Visible Procedure deltypetable() {
  292.     release(typeof);
  293. }
  294.  
  295. /* init */
  296.  
  297. Visible Procedure initpol() {
  298.     num_kind = mk_text("Number");
  299.     num_type = mkt_polytype(num_kind, 0);
  300.     tex_kind = mk_text("Text");
  301.     tex_type = mkt_polytype(tex_kind, 0);
  302.     t_n_kind = mk_text("TN");
  303.     t_n_type = mkt_polytype(t_n_kind, 0);
  304.     err_kind = mk_text("Error");
  305.     err_type = mkt_polytype(err_kind, 0);
  306.     
  307.     lis_kind = mk_text("List");
  308.     tab_kind = mk_text("Table");
  309.     com_kind = mk_text("Compound");
  310.     l_t_kind = mk_text("LT");
  311.     tlt_kind = mk_text("TLT");
  312.     var_kind = mk_text("Variable");
  313.     
  314.     nnewvar = zero;
  315. }
  316.